Modelling and visualizing data

You will learn how to:

• Implement and customize interactivity in plots
• Leverage input events to fine-tune visualizations
• Use proxies to update plots and maps on-the-fly (appendix)
• Turn simple R plots into powerful Swiss knifes

1 Interactive visualization: The core of Shiny

• Shiny offers the perfect basis for visualization
  • Plots can be modified using UI inputs
  • Seamless integration of interactivity elements (e.g. pan, zoom)
  • Dashboards facilitate the idea of story-telling by providing context to plots

1.1 Good practice examples

• Examples of these concepts can be seen in many Shiny apps, one example is Edward Parker’s COVID-19 tracker

Note

Exercise

Explore the COVID-19 tracker. Do you think this is a good Shiny app? If so, why? If not, why not?

COVID-19 Tracker

1.2 Plain plotting vs. Shiny

Feature	Plain R	Shiny	Examples
Reactivity	Changes in the visualization have to be changed in the code	Visualizations can be modified on the fly using widgets like drop-down menus	ExPanD
Interactivity	Plots are static raster or vector images	Plots can be dynamic and can be interacted with	COVID-19 tracker
Narrativity	Sense-making happens through manual annotation, e.g. in an article or a presentation	Plots are embedded in a compilation of narrative elements that can tell a coherent story	Freedom of Press Shiny app GRETA Analytics

Medium	Reactivity	Interactivity	Narrativity
Plain image	❌	❌	❌
Paper / report	❌	❌	✅
Dashboard (e.g. Tableau)	❌	☑️	✅
Quarto / RMarkdown	❌	☑️	✅
Traditional website	☑️	✅	✅
Shiny	✅	✅	✅

1.3 Current app state

• In the last sections, we added a table and a plot and linked them to a number of inputs
• The code chunk below contains the current app state
• In this section, we will:
  • Augment the violin plot
  • Add an interactive map

library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("../../../data/ess_trust.rds")
ess_geo <- readRDS("../../../data/ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      ### filter values ----
      sliderInput(
        "range",
        label = "Set a value range",
        min = min(ess$trust_parliament, na.rm = TRUE),
        max = max(ess$trust_parliament, na.rm = TRUE),
        value = range(ess$trust_parliament, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotOutput("plot", height = 600)
        ),
        
        ### Map tab ----
        tabPanel(
          title = "Map",
          leafletOutput("map", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # update slider ----
  observe({
    var <- na.omit(ess[[input$xvar]])
    is_ordered <- is.ordered(var)
    var <- as.numeric(var)
    updateSliderInput(
      inputId = "range",
      min = min(var),
      max = max(var),
      value = range(var),
      step = if (is_ordered) 1
    )
  }) %>%
    bindEvent(input$xvar)
  
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess <- ess[c("idno", "country", xvar, yvar)]
    
    # apply range
    ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ]
    ess
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlot({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
  })
}

shinyApp(ui = ui, server = server)

1.4 Recap: Plotting in Shiny

• Inserting plots in Shiny apps works just like any other UI component
• You need two things: plotOutput() (or similar) in the UI and renderPlot() (or similar) in the server function
  • plotOutput() creates the empty element in the UI where the plot will go
  • renderPlot() renders the plot and updates the UI element every time a reactive dependency is invalidated

2 Interactivity

• R itself is very bad at interactivity
• Shiny supports some very essential interactivity through plotOutput
  • Not covered in this workshop! For a primer, check out chapter 7.1 of Mastering Shiny
• All of today’s cool kids use interactivity through Javascript interfaces
• Shiny can generally process all kinds of Javascript-based widgets because Shiny apps are HTML documents

2.1 Popular Javascript interfaces

• Examples of Javascript libraries and their corresponding R packages
  • Plotly (covered here)
  • Leaflet (covered here)
  • Highcharts
  • Bokeh
  • D3
  • Apache ECharts
  • Frappe Charts
  • billboard.js
  • apexcharts.js
  • Google Charts
  • amCharts 4
  • Deck.gl
  • WebGL

3 Plotly

• Plotly is an open-source library to create charts that can be interacted with in various way
• It supports several languages including R and Python
• Plotly is arguably the most renowned R package for interactive plotting
• It even motivated an entire book: https://plotly-r.com/

3.1 Plotly’s grammar of graphics

• Similar to ggplot2, R plotly defines its own grammar of graphics
• A plotly canvas is created with plot_ly()
• Additional plot elements can be added through pipes %>% or |>

ess_geo <- readRDS("data/ess_trust_geo.rds")
ess_geo <- mutate(
  ess_geo,
  region = case_match(
    country,
    c("AT", "BE", "CH", "DE", "NL", "PL", "CZ") ~ "Central",
    c("BG", "EE", "HR", "HU", "LT", "LV", "PL", "SI", "SK") ~ "Eastern",
    c("ES", "IT", "PT", "RS", "ME") ~ "Southern",
    c("IS", "SE", "FI", "GB", "IE", "DK") ~ "Northern"
  )
)

plot_ly(
  sf::st_drop_geometry(ess_geo),
  x = ~trust_eu,
  y = ~left_right,
  z = ~age,
  color = ~region,
  text = ~country
) %>%
  add_markers() %>%
  layout(scene = list(
    xaxis = list(title = 'Trust in the EU'),
    yaxis = list(title = 'Left-right placement'),
    zaxis = list(title = 'Age')
  ))

1

Variables such as x, y, z and color are defined as formulas in a call to plot_ly. This is comparable to calling ggplot(aes(x, y, z, color)).

2

The plot type is added through a pipe. This is comparable to ggplot2 functions such as geom_point or geom_bar.

3

Visual sugar is then added by calling layout and manually editing the axis titles.

3.2 Quick and dirty interactivity

• One important advantage of plotly is that you do not need to learn its grammar
• ggplot2 plots can very easily be converted to an interactive plotly plot:

p <- ggplot(iris) +
  geom_point(aes(Sepal.Width, Sepal.Length))
p

ggplotly(p)

3.3 Extending plotly

3.3.1 Customization

• We can extend Plotly objects using three functions:
  • layout() changes the plot organisation (think ggplot2::theme()), e.g.:
    • colors, sizes, fonts, positions, titles, ratios and alignment of all kinds of plot elements
    • updatemenus adds buttons or drop down menus that can change the plot style or layout (see here for examples)
    • sliders adds sliders that can be useful for time series (see here for examples)
  • config() changes interactivity configurations, e.g.:
    • The modeBarButtons options and displaylogo control the buttons in the mode bar
    • toImageButtonOptions controls the format of plot downloads
    • scrollZoom enables or disables zooming by scrolling
  • style() changes data-level attributes (think ggplot2::scale_), e.g.:
    • hoverinfo controls whether tooltips are shown on hover
    • mode controls whether to show points, lines and/or text in a scatter plot
    • hovertext modifies the tooltips texts shown on hover

3.3.2 Schema

• The actual number of options is immense!
• You can explore all options by calling plotly::schema()

schema()

3.3.3 Example

p <- ggplot(iris) +
  geom_point(aes(Sepal.Width, Sepal.Length))

ggplotly(p) %>%
  config(
    modeBarButtonsToRemove = c(
      "sendDataToCloud", "zoom2d", "select2d", "lasso2d", "autoScale2d",
      "hoverClosestCartesian", "hoverCompareCartesian", "resetScale2d"
    ),

    displaylogo = FALSE,

    toImageButtonOptions = list(
      format = "svg",
      filename = "plot",
      height = NULL,
      width = NULL
    ),

    scrollZoom = TRUE
  )

1

Removes specified buttons from the modebar.

2

Removes the Plotly logo.

3

Changes the output of snapshots taken of the plot. Setting height and width to NULL keeps the aspect ratio of the plot as it is shown in the app.

4

Enables zooming through scrolling.

3.4 Plotly and Shiny

• Since plotly does not produce static plots like ggplot2, it cannot be served by plotOutput and renderPlot
• Plotly defines two new functions:
  • plotlyOutput on the UI side
  • renderPlotly on the server side

UI:

mainPanel(
  tabsetPanel(
    type = "tabs",
    
    ### Table tab ----
    tabPanel(
      title = "Table",
      div(
        style = "height: 600px; overflow-y: auto;",
        tableOutput("table")
      )
    ),
    
    ### Plot tab ----
    tabPanel(
      title = "Plot",
      plotlyOutput("plot", height = 600)
    )
  )
)

Server:

output$plot <- renderPlotly({
  xvar <- input$xvar
  yvar <- input$yvar
  plot_data <- filtered() %>%
    drop_na() %>%
    mutate(across(where(is.numeric), .fns = as.ordered))
  
  p <- ggplot(plot_data) +
    aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
    geom_violin(fill = "lightblue", show.legend = FALSE) +
    theme_classic()
  ggplotly(p)
})

library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("../../../data/ess_trust.rds")
ess_geo <- readRDS("../../../data/ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      ### filter values ----
      sliderInput(
        "range",
        label = "Set a value range",
        min = min(ess$trust_parliament, na.rm = TRUE),
        max = max(ess$trust_parliament, na.rm = TRUE),
        value = range(ess$trust_parliament, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotlyOutput("plot", height = 600)
        ),
        
        ### Map tab ----
        tabPanel(
          title = "Map",
          leafletOutput("map", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # update slider ----
  observe({
    var <- na.omit(ess[[input$xvar]])
    is_ordered <- is.ordered(var)
    var <- as.numeric(var)
    updateSliderInput(
      inputId = "range",
      min = min(var),
      max = max(var),
      value = range(var),
      step = if (is_ordered) 1
    )
  }) %>%
    bindEvent(input$xvar)
  
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess <- ess[c("idno", "country", xvar, yvar)]
    
    # apply range
    ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ]
    ess
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlotly({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    p <- ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
    ggplotly(p)
  })
}

shinyApp(ui = ui, server = server)

4 Leaflet

• Leaflet is an open-source JavaScript library to create interactive maps
• Like plotly it is one of the most popular applications for interactive mapping
• The leaflet package makes it easy to create interactive maps directly in R
• Leaflet is very light-weight! This is good, but it’s also bad because it means extra work.

4.1 Leaflet’s grammar of graphics

• Just like ggplot2 and plotly, leaflet is inspired by a grammar of graphics
• A map canvas can be created using the leaflet() function
• Additional elements are added through pipes %>% or |>
• Palettes are created using the leaflet::color function family

leaflet(ess_geo) %>%
  addTiles() %>%
  addPolygons(
    weight = 2,
    opacity = 1,
    fillOpacity = 0.7
  )

1

Leaflet supports four types of palettes: Bin, Quantile, Factor, and Numeric. In this case we have a numeric variable.

2

leaflet() is the powerhorse of the leaflet package. It is comparable to ggplot() or plot_ly().

3

addTiles() adds a background map.

4

addPolygons() adds polygons to the map. This function accepts several visual arguments to control, for example, the line width and opacity.

4.2 Adding data

• To add colorized data, we must first define how to color this data
• Leaflet defines four color functions to create a palette:
  • Numeric
  • Bin
  • Quantile
  • Factor
• Depending on the data

pal <- colorNumeric("YlOrRd", domain = NULL)

leaflet(ess_geo) %>%
  addTiles() %>%
  addPolygons(
    fillColor = pal(ess_geo[["trust_eu"]]),
    weight = 2,
    opacity = 1,
    color = "white",
    fillOpacity = 0.7
  )

1

Define a numeric palette with a gradient Yellow-Orange-Red

2

Apply this palette to the data to generate color values

4.3 Adding a legend

• Just like adding data, adding legends has to be done manually
• The addLegend() function

pal <- colorNumeric("YlOrRd", domain = NULL)

leaflet(ess_geo) %>%
  addTiles() %>%
  addPolygons(
    fillColor = pal(ess_geo[["trust_eu"]]),
    weight = 2,
    opacity = 1,
    color = "white",
    fillOpacity = 0.7
  ) %>%
  addLegend(
    position = "bottomleft",
    pal = pal,
    values = ess_geo[["trust_eu"]],
    opacity = 0.7,
    title = "Trust in the EU"
  )

4.4 Adding interactivity

• Right now, the leaflet map cannot be interacted with
• Interactivity has to be added manually
• Two new features:
  • highlightOptions adds a highlight effect when hovering over a polygon
  • labels adds labels that appear when hovering over a polygon
• Caveats:
  • Labels have to be formatted manually, as per usual
  • Beautifully styled labels require some knowledge of HTML and CSS

labels <- sprintf(
  "<strong>%s</strong><br>%s",
  ess_geo$country,
  ess_geo$trust_eu
)
labels <- lapply(labels, HTML)

pal <- colorNumeric("YlOrRd", domain = NULL)

leaflet(ess_geo) %>%
  addTiles() %>%
  addPolygons(
    fillColor = pal(ess_geo[["trust_eu"]]),
    weight = 2,
    opacity = 1,
    color = "white",
    fillOpacity = 0.7,
    highlightOptions = highlightOptions(
      weight = 2,
      color = "#666",
      fillOpacity = 0.7,
      bringToFront = TRUE
    ),
    label = labels
  ) %>%
  addLegend(
    position = "bottomleft",
    pal = pal,
    values = ess_geo[["trust_eu"]],
    opacity = 0.7,
    title = "Trust in the EU"
  )

1

Labels need to be created manually. Here, I generate very essential labels containing the country in bold and the trust value below it.

2

Labels must be explicitly classified as HTML code. This can be done using the shiny::HTML function.

3

Interactivity is then simply added through the label and highlightOptions arguments to addPolygons().

4.5 Leaflet and Shiny

• Again, Leaflet does not produce static plots and thus cannot be served by plotOutput and renderPlot
• The leaflet package defines two functions:
  • leafletOutput to create the canvas in the UI
  • renderLeaflet to render the Leaflet widget in the server function

UI:

mainPanel(
  tabsetPanel(
    type = "tabs",
    
    ### Table tab ----
    tabPanel(
      title = "Table",
      div(
        style = "height: 600px; overflow-y: auto;",
        tableOutput("table")
      )
    ),
    
    ### Plot tab ----
    tabPanel(
      title = "Plot",
      plotlyOutput("plot", height = 600)
    ),
    
    ### Map tab ----
    tabPanel(
      title = "Map",
      leafletOutput("map", height = 600)
    )
  )
)

Server:

output$map <- renderLeaflet({
  var <- input$xvar
  plot_data <- ess_geo[c("country", var)]
  
  # create labels with a bold title and a body
  labels <- sprintf(
    "<strong>%s</strong><br>%s",
    plot_data$country,
    plot_data[[var]]
  )
  labels <- lapply(labels, HTML)
  
  # create a palette for numerics and ordinals
  if (is.ordered(plot_data[[var]])) {
    pal <- colorFactor("YlOrRd", domain = NULL)
  } else {
    pal <- colorNumeric("YlOrRd", domain = NULL)
  }

  # construct leaflet canvas
  leaflet(plot_data) %>%
    # add base map
    addTiles() %>%
    # add choropleths
    addPolygons(
      fillColor = pal(plot_data[[var]]),
      weight = 2,
      opacity = 1,
      color = "white",
      fillOpacity = 0.7,
      # highlight polygons on hover
      highlightOptions = highlightOptions(
        weight = 2,
        color = "#666",
        fillOpacity = 0.7,
        bringToFront = TRUE
      ),
      label = labels
    ) %>%
    # add a legend
    addLegend(
      position = "bottomleft",
      pal = pal,
      values = plot_data[[var]],
      opacity = 0.7,
      title = var
    )
})

library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("../../../data/ess_trust.rds")
ess_geo <- readRDS("../../../data/ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      ### filter values ----
      sliderInput(
        "range",
        label = "Set a value range",
        min = min(ess$trust_parliament, na.rm = TRUE),
        max = max(ess$trust_parliament, na.rm = TRUE),
        value = range(ess$trust_parliament, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotlyOutput("plot", height = 600)
        ),
        
        ### Map tab ----
        tabPanel(
          title = "Map",
          leafletOutput("map", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # update slider ----
  observe({
    var <- na.omit(ess[[input$xvar]])
    is_ordered <- is.ordered(var)
    var <- as.numeric(var)
    updateSliderInput(
      inputId = "range",
      min = min(var),
      max = max(var),
      value = range(var),
      step = if (is_ordered) 1
    )
  }) %>%
    bindEvent(input$xvar)
  
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess <- ess[c("idno", "country", xvar, yvar)]
    
    # apply range
    ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ]
    ess
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlotly({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    p <- ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
    ggplotly(p)
  })
  
  # render map ----
  output$map <- renderLeaflet({
    var <- input$xvar
    ess_geo <- ess_geo[c("country", var)]
    
    # create labels with a bold title and a body
    labels <- sprintf(
      "<strong>%s</strong><br>%s",
      ess_geo$country,
      ess_geo[[var]]
    )
    labels <- lapply(labels, HTML)
    
    # create a palette for numerics and ordinals
    if (is.ordered(ess_geo[[var]])) {
      pal <- colorFactor("YlOrRd", domain = NULL)
    } else {
      pal <- colorNumeric("YlOrRd", domain = NULL)
    }
    
    # construct leaflet canvas
    leaflet(ess_geo) %>%
      # add base map
      addTiles() %>%
      # add choropleths
      addPolygons(
        fillColor = pal(ess_geo[[var]]),
        weight = 2,
        opacity = 1,
        color = "white",
        fillOpacity = 0.7,
        # highlight polygons on hover
        highlightOptions = highlightOptions(
          weight = 2,
          color = "#666",
          fillOpacity = 0.7,
          bringToFront = TRUE
        ),
        label = labels
      ) %>%
      # add a legend
      addLegend(
        position = "bottomleft",
        pal = pal,
        values = ess_geo[[var]],
        opacity = 0.7,
        title = var
      )
  })
}

shinyApp(ui = ui, server = server)

5 Reactivity

• We already covered Shiny’s reactivity quite extensively
• Recall:
  • A user changes an input
  • The server processes that input
  • The UI updates
• It turns out, most plotting systems in Shiny support what we will call “plot events”

5.1 Plot events

• A plot event is triggered by a widget if a user interacts with it
• In a sense, plot events are a cross-over of interactivity and reactivity
• A plot event is hidden, i.e. it does not have to be explicitly defined in the UI – it’s just created automatically on the go.
• By far not all widgets define plot events, but the most important plotting frameworks do:
  • plotly defines a plethora of plot events through the event_data function
  • leaflet automatically creates a number of plot events for each map
  • Even basic plotting supports plot events through additional arguments to plotOutput
• To illustrate plot events, we will use leaflet events

5.2 Leaflet’s plot events

• Leaflet events are accessed like so:

input$<Map ID>_<Object type>_<Event type>

• Map ID refers to the input ID given to the leaflet map

5.2.1 Leaflet object types

• “Object type” refers to the geometry, which can be one of:
  • marker for points
  • shape for polygons and lines
  • geojson and topojson for data that was passed in GeoJSON or TopoJSON format

5.2.2 Leaflet event types

• “Event type” refers to the action that is performed on the geometry to trigger the event, one of:
  • click
  • mouseover
  • mouseout

5.2.3 Other events

• Additionally, Leaflet has some more general events:
  • input$<Map ID>_click triggers when the background of the map is clicked
  • input$<Map ID>_bounds provides the bounding box of the current view
  • input$<Map ID>_zoom provides the current zoom level
  • input$<Map ID>_center provides the center point of the current view

6 Proxies

• Similar to plot events, most Shiny plotting frameworks implement what is called proxies
• A proxy is a representation of an existing widget
• Such proxies can be manipulated in place, i.e. they do not need to be re-rendered

6.1 Proxies in Shiny frameworks

• Many Shiny extensions provide proxy functions:
  • DT::dataTableProxy()
  • plotly::plotlyProxy()
  • leaflet::leafletProxy()

6.2 Proxy workflow

1. Initialize an isolated output widget (i.e., no dependencies) / isolate()
2. Create an observer that updates input dependencies / observe()
3. Invalidate an input
4. Remove existing features and add new ones

Reactive graph for proxies

6.3 Manipulating proxies

• Proxies are best combined with functions that add to, remove to, or clear a widget
• The following table summarizes these functions

Category	Add functions	Remove	Clear
tile	addTiles(), addProviderTiles()	removeTiles()	clearTiles()
marker	addMarkers(), addCircleMarkers()	removeMarker()	clearMarkers()
shape	addPolygons(), addPolylines(), addCircles(), addRectangles()	removeShape()	clearShapes()
geojson	addGeoJSON()	removeGeoJSON()	clearGeoJSON()
topojson	addTopoJSON()	removeTopoJSON()	clearTopoJSON()
control	addControl()	removeControl()	clearControls()

6.4 Synthesis: Plot events, proxies, and plot manipulation

• Proxies unleash their potential when combined with plot events and plot manipulation:
• This combination allows users to manipulate plots themselves (e.g. adding or removing elements)
• The following example makes use of all three concepts to create a map that can add and remove simple markers
  • Plot events: input$map_click and input$map_marker_click to register where markers should be added and removed
  • leafletProxy("map"): A proxy is needed to manipulate the map without resetting the view
  • addMarkers and removeMarker to add and remove markers

ui <- fluidPage(
  leafletOutput("map")
)

server <- function(input, output, session) {

  # initial map render
  output$map <- renderLeaflet({
    leaflet() %>%
      addTiles() %>%
      setView(lng = 7, lat = 52, zoom = 7)
  })

  # add marker
  observe({
    click <- input$map_click
    leafletProxy("map") %>%
      addMarkers(lng = click$lng, lat = click$lat, layerId = toString(click))
  }) %>%
    bindEvent(input$map_click)

  # remove marker
  observe({
    click <- input$map_marker_click
    leafletProxy("map") %>%
      removeMarker(click$id)
  }) %>%
    bindEvent(input$map_marker_click)
}

runApp(shinyApp(ui, server))

1

Render the leaflet map once. Note that the render function does not take any dependencies and is thus only run once.

2

Add a marker every time the map is clicked somewhere. Note that the marker is added not to a new map, but to a proxy of the map that is already rendered.

3

Remove a marker that is clicked. Note how the observer is only triggered when a marker is clicked, i.e. when input$map_marker_click is triggered.

7 Exercise session

7.1 Plotly

Exercise 1.1

Add a new tab to the app. Add an output canvas to the UI and a render function to the server function such that the new tab is able to display an interactive plotly widget.

Solution 1.2

In the UI, add a new tabPanel() to the tabsetPanel().

mainPanel(
  tabsetPanel(
    type = "tabs",
    
    ### Table tab ----
    tabPanel(
      title = "Table",
      div(
        style = "height: 600px; overflow-y: auto;",
        tableOutput("table")
      )
    ),
    
    ### Plot tab ----
    tabPanel(
      title = "Plot",
      plotlyOutput("plot", height = 600)
    ),
    
    ### Map tab ----
    tabPanel(
      title = "Map",
      leafletOutput("map", height = 600)
    ),

    ### New tab ----
    tabPanel(
      title = "Histogram",
      plotlyOutput("hist", height = 600)
    )
  )
)

In the server function, add renderPlotly and assign it to the output object.

output$hist <- renderPlotly({

})

library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("data/ess_trust.rds")
ess_geo <- readRDS("data/ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      ### filter values ----
      sliderInput(
        "range",
        label = "Set a value range",
        min = min(ess$trust_parliament, na.rm = TRUE),
        max = max(ess$trust_parliament, na.rm = TRUE),
        value = range(ess$trust_parliament, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotlyOutput("plot", height = 600)
        ),
        
        ### Map tab ----
        tabPanel(
          title = "Map",
          leafletOutput("map", height = 600)
        ),

        ### New tab ----
        tabPanel(
          title = "Histogram",
          plotlyOutput("hist", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # update slider ----
  observe({
    var <- na.omit(ess[[input$xvar]])
    is_ordered <- is.ordered(var)
    var <- as.numeric(var)
    updateSliderInput(
      inputId = "range",
      min = min(var),
      max = max(var),
      value = range(var),
      step = if (is_ordered) 1
    )
  }) %>%
    bindEvent(input$xvar)
  
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess <- ess[c("idno", "country", xvar, yvar)]
    
    # apply range
    ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ]
    ess
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlotly({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    p <- ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
    ggplotly(p)
  })
  
  # render map ----
  output$map <- renderLeaflet({
    var <- input$xvar
    ess_geo <- ess_geo[c("country", var)]
    
    # create labels with a bold title and a body
    labels <- sprintf(
      "<strong>%s</strong><br>%s",
      ess_geo$country,
      ess_geo[[var]]
    )
    labels <- lapply(labels, HTML)
    
    # create a palette for numerics and ordinals
    if (is.ordered(ess_geo[[var]])) {
      pal <- colorFactor("YlOrRd", domain = NULL)
    } else {
      pal <- colorNumeric("YlOrRd", domain = NULL)
    }
    
    # construct leaflet canvas
    leaflet(ess_geo) %>%
      # add base map
      addTiles() %>%
      # add choropleths
      addPolygons(
        fillColor = pal(ess_geo[[var]]),
        weight = 2,
        opacity = 1,
        color = "white",
        fillOpacity = 0.7,
        # highlight polygons on hover
        highlightOptions = highlightOptions(
          weight = 2,
          color = "#666",
          fillOpacity = 0.7,
          bringToFront = TRUE
        ),
        label = labels
      ) %>%
      # add a legend
      addLegend(
        position = "bottomleft",
        pal = pal,
        values = ess_geo[[var]],
        opacity = 0.7,
        title = var
      )
  })
  
  output$hist <- renderPlotly({
    
  })
}

shinyApp(ui = ui, server = server)

Exercise 1.2

In section 3, we implemented a bivariate plot of the ESS data. For this exercise, create a univariate plotly plot of one of the trust variables. In the solution, I will be using a histogram, but this could also be a stacked bar chart, a kernel density curve, etc. The idea is to get a quick overview of the statistical distribution of a trust variable.

You can do this either through plotly’s own grammar (plot_ly()) or by converting a ggplot (ggplotly()). In the solutions, I will be using plotly though.

Note that, due to a bug in plotly, the labels of the ESS dataset have to be removed from the dataset. This can be done either by casting as.numeric on a variable or by zapping labels with haven::zap_labels().

Solution 1.2

The following solution implements a histogram of the trust_parliament variable.

ess <- readRDS("data/ess_trust.rds")

plot_ly(ess, x = ~as.numeric(trust_parliament)) %>%
  add_histogram()

Exercise 1.3

Customize the plotly plot according to the following requests:

• Change the axis titles to something useful
• Decrease the opacity to 70%
• Remove the modebar
• Increase the gap between histogram bars to 20%.
• Change the bar color to green

Tip

Recall that plotly can be customized using the layout, style, and config functions.

To find out about options specific to a plotly histogram, call plotly::schema() and navigate to traces -> histogram.

Plotly can be very confusing and there is no shame in using google!

Solution 1.3

plot_ly(ess) %>%
  add_histogram(x = ~as.numeric(trust_parliament)) %>%

  # everything that changes the overall theming goes here
  layout(
      xaxis = list(title = "Trust in the national parliament"),
      yaxis = list(title = "Observations"),
      bargap = 0.2
  ) %>%

  # everything that changes the data- and plot-specific theming goes here
  style(opacity = 0.7, marker = list(color = "green")) %>%

  # everything that changes the interactivity goes here
  config(displayModeBar = FALSE)

Exercise 1.4

Implement the plot from exercise 1.3 in the Shiny app. Instead of plotting a single static variable, link the histogram to the input selector for the dependent variable (input$xvar) such that choosing a different trust variable updates the histogram.

Solution 1.4

output$hist <- renderPlotly({
  plot_ly(filtered()) %>%
  add_histogram(x = as.numeric(ess[input$xvar])) %>%

  # everything that changes the overall theming goes here
  layout(
      xaxis = list(title = "Trust in the national parliament"),
      yaxis = list(title = "Observations"),
      bargap = 0.2
  ) %>%

  # everything that changes the data- and plot-specific theming goes here
  style(opacity = 0.7, marker = list(color = "green")) %>%

  # everything that changes the interactivity goes here
  config(displayModeBar = FALSE)
})

library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("data/ess_trust.rds")
ess_geo <- readRDS("data/ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      ### filter values ----
      sliderInput(
        "range",
        label = "Set a value range",
        min = min(ess$trust_parliament, na.rm = TRUE),
        max = max(ess$trust_parliament, na.rm = TRUE),
        value = range(ess$trust_parliament, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotlyOutput("plot", height = 600)
        ),
        
        ### Map tab ----
        tabPanel(
          title = "Map",
          leafletOutput("map", height = 600)
        ),
        
        ### New tab ----
        tabPanel(
          title = "Histogram",
          plotlyOutput("hist", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # update slider ----
  observe({
    var <- na.omit(ess[[input$xvar]])
    is_ordered <- is.ordered(var)
    var <- as.numeric(var)
    updateSliderInput(
      inputId = "range",
      min = min(var),
      max = max(var),
      value = range(var),
      step = if (is_ordered) 1
    )
  }) %>%
    bindEvent(input$xvar)
  
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess <- ess[c("idno", "country", xvar, yvar)]
    
    # apply range
    ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ]
    ess
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlotly({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    p <- ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
    ggplotly(p)
  })
  
  # render map ----
  output$map <- renderLeaflet({
    var <- input$xvar
    ess_geo <- ess_geo[c("country", var)]
    
    # create labels with a bold title and a body
    labels <- sprintf(
      "<strong>%s</strong><br>%s",
      ess_geo$country,
      ess_geo[[var]]
    )
    labels <- lapply(labels, HTML)
    
    # create a palette for numerics and ordinals
    if (is.ordered(ess_geo[[var]])) {
      pal <- colorFactor("YlOrRd", domain = NULL)
    } else {
      pal <- colorNumeric("YlOrRd", domain = NULL)
    }
    
    # construct leaflet canvas
    leaflet(ess_geo) %>%
      # add base map
      addTiles() %>%
      # add choropleths
      addPolygons(
        fillColor = pal(ess_geo[[var]]),
        weight = 2,
        opacity = 1,
        color = "white",
        fillOpacity = 0.7,
        # highlight polygons on hover
        highlightOptions = highlightOptions(
          weight = 2,
          color = "#666",
          fillOpacity = 0.7,
          bringToFront = TRUE
        ),
        label = labels
      ) %>%
      # add a legend
      addLegend(
        position = "bottomleft",
        pal = pal,
        values = ess_geo[[var]],
        opacity = 0.7,
        title = var
      )
  })
  
  output$hist <- renderPlotly({
    plot_ly(filtered()) %>%
      add_histogram(x = as.numeric(ess[[input$xvar]])) %>%
      
      # everything that changes the overall theming goes here
      layout(
        xaxis = list(title = input$xvar),
        yaxis = list(title = "Observations"),
        bargap = 0.2
      ) %>%
      
      # everything that changes the data- and plot-specific theming goes here
      style(opacity = 0.7, marker = list(color = "green")) %>%
      
      # everything that changes the interactivity goes here
      config(displayModeBar = FALSE)
  })
}

shinyApp(ui = ui, server = server)

7.2 Leaflet

7.3 Plot events

7.4 Beyond plotly and leaflet

Exercise 4.1

Thinking back to the list of Javascript libraries for interactive plotting in section 2.1, pick one R interface that appeals to you the most. Study its documentation and vignettes to get a basic understanding of the interface.

Exercise 4.2

Add a new tab to the app. Replicate the violin plots from section 3 as boxplots using an R interface of your choice.

Note that not all plotting libraries support violin and boxplots to the same degree.

Example solution 4.2

An example solution with the highcharter package:

library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("../../../data/ess_trust.rds")
ess_geo <- readRDS("../../../data/ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      ### filter values ----
      sliderInput(
        "range",
        label = "Set a value range",
        min = min(ess$trust_parliament, na.rm = TRUE),
        max = max(ess$trust_parliament, na.rm = TRUE),
        value = range(ess$trust_parliament, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotlyOutput("plot", height = 600)
        ),
        
        ### Map tab ----
        tabPanel(
          title = "Map",
          leafletOutput("map", height = 600)
        ),
        
        ### Highcharts tab ----
        tabPanel(
          title = "Highcharts",
          highchartOutput("highcharts", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # update slider ----
  observe({
    var <- na.omit(ess[[input$xvar]])
    is_ordered <- is.ordered(var)
    var <- as.numeric(var)
    updateSliderInput(
      inputId = "range",
      min = min(var),
      max = max(var),
      value = range(var),
      step = if (is_ordered) 1
    )
  }) %>%
    bindEvent(input$xvar)
  
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess <- ess[c("idno", "country", xvar, yvar)]
    
    # apply range
    ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ]
    ess
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlotly({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    p <- ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
    ggplotly(p)
  })
  
  # render map ----
  output$map <- renderLeaflet({
    var <- input$xvar
    ess_geo <- ess_geo[c("country", var)]
    
    # create labels with a bold title and a body
    labels <- sprintf(
      "<strong>%s</strong><br>%s",
      ess_geo$country,
      ess_geo[[var]]
    )
    labels <- lapply(labels, HTML)
    
    # create a palette for numerics and ordinals
    if (is.ordered(ess_geo[[var]])) {
      pal <- colorFactor("YlOrRd", domain = NULL)
    } else {
      pal <- colorNumeric("YlOrRd", domain = NULL)
    }
    
    # construct leaflet canvas
    leaflet(ess_geo) %>%
      # add base map
      addTiles() %>%
      # add choropleths
      addPolygons(
        fillColor = pal(ess_geo[[var]]),
        weight = 2,
        opacity = 1,
        color = "white",
        fillOpacity = 0.7,
        # highlight polygons on hover
        highlightOptions = highlightOptions(
          weight = 2,
          color = "#666",
          fillOpacity = 0.7,
          bringToFront = TRUE
        ),
        label = labels
      ) %>%
      # add a legend
      addLegend(
        position = "bottomleft",
        pal = pal,
        values = ess_geo[[var]],
        opacity = 0.7,
        title = var
      )
  })
  
  # render highcharts
  output$highcharts <- renderHighchart({
    xvar <- input$xvar
    yvar <- input$yvar
    
    ess <- filtered() %>%
      zap_labels() %>%
      na.omit() %>%
      select(all_of(c(xvar, yvar))) %>%
      setNames(c("x", "y"))
    
    highchart() %>%
      hc_add_series_list(data_to_boxplot(
        ess,
        x,
        y,
        color = "black",
        fillColor = "#ADD8E6",
        showInLegend = FALSE,
        name = xvar
      )) %>%
      hc_yAxis(
        min = 0, max = max(ess$y, na.rm = TRUE),
        title = list(text = yvar)
      ) %>%
      hc_xAxis(type = "category", title = list(text = xvar)) %>%
      hc_legend(enabled = FALSE)
  })
}

shinyApp(ui = ui, server = server)

An example solution with the apexcharter package:

library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("../../../data/ess_trust.rds")
ess_geo <- readRDS("../../../data/ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      ### filter values ----
      sliderInput(
        "range",
        label = "Set a value range",
        min = min(ess$trust_parliament, na.rm = TRUE),
        max = max(ess$trust_parliament, na.rm = TRUE),
        value = range(ess$trust_parliament, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotlyOutput("plot", height = 600)
        ),
        
        ### Map tab ----
        tabPanel(
          title = "Map",
          leafletOutput("map", height = 600)
        ),
        
        ### Highcharts tab ----
        tabPanel(
          title = "Highcharts",
          apexchartOutput("highcharts", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # update slider ----
  observe({
    var <- na.omit(ess[[input$xvar]])
    is_ordered <- is.ordered(var)
    var <- as.numeric(var)
    updateSliderInput(
      inputId = "range",
      min = min(var),
      max = max(var),
      value = range(var),
      step = if (is_ordered) 1
    )
  }) %>%
    bindEvent(input$xvar)
  
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess <- ess[c("idno", "country", xvar, yvar)]
    
    # apply range
    ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ]
    ess
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlotly({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    p <- ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
    ggplotly(p)
  })
  
  # render map ----
  output$map <- renderLeaflet({
    var <- input$xvar
    ess_geo <- ess_geo[c("country", var)]
    
    # create labels with a bold title and a body
    labels <- sprintf(
      "<strong>%s</strong><br>%s",
      ess_geo$country,
      ess_geo[[var]]
    )
    labels <- lapply(labels, HTML)
    
    # create a palette for numerics and ordinals
    if (is.ordered(ess_geo[[var]])) {
      pal <- colorFactor("YlOrRd", domain = NULL)
    } else {
      pal <- colorNumeric("YlOrRd", domain = NULL)
    }
    
    # construct leaflet canvas
    leaflet(ess_geo) %>%
      # add base map
      addTiles() %>%
      # add choropleths
      addPolygons(
        fillColor = pal(ess_geo[[var]]),
        weight = 2,
        opacity = 1,
        color = "white",
        fillOpacity = 0.7,
        # highlight polygons on hover
        highlightOptions = highlightOptions(
          weight = 2,
          color = "#666",
          fillOpacity = 0.7,
          bringToFront = TRUE
        ),
        label = labels
      ) %>%
      # add a legend
      addLegend(
        position = "bottomleft",
        pal = pal,
        values = ess_geo[[var]],
        opacity = 0.7,
        title = var
      )
  })
  
  # render highcharts
  output$highcharts <- renderApexchart({
    xvar <- input$xvar
    yvar <- input$yvar
    
    apex(filtered(), aes(.data[["trust_eu"]], .data[["left_right"]]), "boxplot") %>%
      ax_plotOptions(boxPlot = boxplot_opts(color.upper = "#ADD8E6", color.lower = "#ADD8E6")) %>%
      ax_stroke(colors = list("black")) %>%
      ax_labs(x = "eu_trust", y = "left_right")
  })
}

shinyApp(ui = ui, server = server)